Com esta anĂĄlise temos como objetivo responder Ă questĂŁo De que forma a mobilidade estĂĄ associada Ă ocorrĂȘncia de novos casos?
Deste modo, queremos perceber se o movimento de pessoas estĂĄ associado a um aumento do nĂșmero de casos de COVID19 quer a nĂvel nacional, quer a nĂvel distrital.
Para esta anĂĄlise baseĂĄmo-nos na metodologia usada pelo artigo do The Lancet.
Para obtermos os dados da movimentação da população por distrito em Portugal, recorremos Ă base de dados disponĂvel em The Humanitarian Data Exchange cuja explicação das fĂłrmulas utilizadas se encontra em Facebook Research. Relativamente aos dados da taxa de crescimento de novos casos utilizĂĄmos a base de dados disponĂvel no github da Data Science for Social Good Portugal.
# IMPORTAR LIBRARIES
library(data.table)
library(dplyr)
library(zoo)
library(geojsonio)
library(leaflet)
library(htmlwidgets)
library(htmltools)
library(ggplot2)
library(plotly)
library(stringdist)
library(Ecfun)
library(tibble)
library(ggpmisc)
library(corrr)
# IMPORTAR BASE DE DADOS SOBRE MOBILIDADE DIĂRIA POR DISTRITOS NO MUNDO DISPONIVEIS EM: <https://data.humdata.org/dataset/movement-range-maps>
mobilidade_r <- fread("C:/Users/rakac/OneDrive - Universidade de Lisboa/R/Faculdade/2.COVID19 Portugal/Partilhado/Mobilidade_COVID19/dados_mobilidade/movement-range-2020-10-10.txt")
#mobilidade_c <- fread("C:/Users/karol/Documents/R/Covid-19_estagio/Epivet2020/movement-range-2020-10-10.txt")
# IMPORTAR BASE DE DADOS DO COVID19 EM PORTUGAL DISPONIVEL EM: <https://github.com/dssg-pt/covid19pt-data>
covid19pt <- fread("https://raw.githubusercontent.com/dssg-pt/covid19pt-data/master/data.csv")
## por as datas em formato data
covid19pt$data <- as.Date(as.character(covid19pt$data),format = "%d-%m-%Y")
# IMPORTAR BASE DE DADOS DOS CASOS POR CONCELHO DISPONIVEL EM: <https://github.com/dssg-pt/covid19pt-data>
covid_concelhos <- fread("https://raw.githubusercontent.com/dssg-pt/covid19pt-data/master/data_concelhos.csv")
# IMPORTAR BASE DE DADOS QUE CORRELACIONA CONCELHOS COM DSTRITOS DISPONIVEL EM: <https://www.factorvirtual.com/blog/distritos-concelhos-e-freguesias-de-portugal>
concelho_distrito <- fread("https://raw.githubusercontent.com/EpiVet2020/Mobilidade_COVID19/main/concelho_distrito.csv?token=AO4UTAQEC3FVBS56S6XDNYC7R3ZL2") %>%
select("DesignaçĂÂŁo DT", "DesignaçĂÂŁo CC")
# IMPORTAR MAPA DOS DISTRITOS DE PORTUGAL DISPONIVEIS EM: <https://github.com/ufoe/d3js-geojson/blob/master/Portugal.json>
mapa_distritos <- geojson_read("https://raw.githubusercontent.com/ufoe/d3js-geojson/master/Portugal.json", what = "sp")
A base de dados da mobilidade apresenta valores entre -1 e 1. Os valores negativos indicam uma diminuição da movimentação de pessoas em Portugal quando comparado com um dia padrĂŁo antes do inĂcio da pandemia (fevereiro) e os valores positivos indicam um aumento dessa movimentação.
No artigo The Lancet os valores da mobilidade variam entre 0 e >1. O valor 0 indica que nĂŁo houve movimentaçÔes, 0.5 significa que foram feitas metade das movimentaçÔes em relação ao padrĂŁo, 1 indica que nĂŁo houve alteração no nĂșmero de movimentaçÔes em relação ao padrĂŁo e >1 significa que o nĂșmero de movimentaçÔes aumentou.
Para os nossos dados terem o mesmo intervalo do que o do artigo, decidimos normalizar os nossos dados somando 1.
# TRATAR BASE DE DADOS DA MOBILIDADE
## Selecionar Portugal na base de dados
mobilidade_pt <- mobilidade_r %>%
filter(country=="PRT")
## Corrigir os nomes dos distritos
mobilidade_pt$polygon_name[mobilidade_pt$polygon_name == "Santar-m" | mobilidade_pt$polygon_name == "Santarém"] <- "Santarem"
mobilidade_pt$polygon_name[mobilidade_pt$polygon_name == "Set-bal" | mobilidade_pt$polygon_name == "SetĂÂșbal"] <- "Setubal"
mobilidade_pt$polygon_name[mobilidade_pt$polygon_name == "Bragan-a" | mobilidade_pt$polygon_name == "Bragança"] <- "Braganca"
mobilidade_pt$polygon_name[mobilidade_pt$polygon_name == "-vora" | mobilidade_pt$polygon_name == "Ăâ°vora"] <- "Evora"
## Normalizar mobility rate para que o 0 passe a representar a ausĂȘncia de mobilidade
mobilidade_pt$all_day_bing_tiles_visited_relative_change = mobilidade_pt$all_day_bing_tiles_visited_relative_change + 1
Uma vez que apenas temos a taxa de mobilidade por distrito, recorremos à média ponderada para obter a taxa de mobilidade diåria nacional.
Neste grĂĄfico podemos ver que desde o inĂcio da pandemia atĂ© Ă atualidade, a curva da tendĂȘncia da taxa de mobilidade tem sido sempre inferior Ă mobilidade utilizada como padrĂŁo (fevereiro), uma vez que a taxa de mobilidade Ă© sempre inferior a 1. Ă possĂvel verificar que nos meses da quarentena (abril e maio) a curva da tendĂȘncia da taxa de mobilidade atingiu o seu valor mĂnimo, cerca de 60%, o que significa que foram feitos 60% dos movimentos realizados em fevereiro, ou seja, uma redução de 40% das deslocaçÔes. A partir de maio, com o fim do isolamento obrigatĂłrio, a taxa de mobilidade subiu atingindo o seu valor mĂĄximo em meados de agosto, provavelmente devido a um maior nĂșmero de movimentaçÔes, intrĂnseco ao perĂodo de fĂ©rias. A partir de setembro, com o fim do perĂodo de fĂ©rias, a taxa de mobilidade tem vindo a diminuir.
# Dados do numero de pessoas por distrito disponiveis em <https://pt.db-city.com/Portugal>
pop_guarda = 176086
pop_leiria = 472895
pop_lisboa = 2203503
pop_madeira = 244286
pop_portalegre = 121653
pop_porto = 1805015
pop_santarem = 463676
pop_setubal = 829007
pop_vianadocastelo = 251937
pop_vilareal = 221218
pop_aveiro = 727041
pop_viseu = 395202
pop_acores = 241206
pop_beja = 156259
pop_braga = 851337
pop_braganca = 280180
pop_castelobranco = 203769
pop_coimbra = 437642
pop_evora = 171130
pop_faro = 411468
# Selecionar na tabela da mobilidade as colunas da data, distrito e mobilidade
mobilidade_distritos <- mobilidade_pt %>%
select(ds, polygon_name, all_day_bing_tiles_visited_relative_change)
names(mobilidade_distritos) = c("data", "distrito", "mobilidade")
# Tabela com a populacao por distrito
pop_distritos <- data.frame(distrito = c("Guarda", "Leiria", "Lisboa", "Madeira", "Portalegre", "Porto", "Santarem", "Setubal",
"Viana do Castelo","Vila Real", "Aveiro", "Viseu", "Azores", "Beja", "Braga", "Braganca",
"Castelo Branco", "Coimbra", "Evora", "Faro"),
populacao = c(pop_guarda, pop_leiria , pop_lisboa, pop_madeira, pop_portalegre, pop_porto, pop_santarem,
pop_setubal, pop_vianadocastelo,pop_vilareal, pop_aveiro, pop_viseu, pop_acores, pop_beja,
pop_braga, pop_braganca, pop_castelobranco, pop_coimbra, pop_evora,pop_faro))
#Juntar as duas tabelas anteriores pelo distrito
mobilidade_distritos <- left_join(mobilidade_distritos, pop_distritos, by = "distrito")
# Nova coluna com a multiplicacao da mobilidade pela populacao de cada distrito (para a media ponderada)
mobilidade_distritos <- mobilidade_distritos %>%
mutate(mobilidadexpopulacao = mobilidade * populacao)
# Tabela com a media ponderada do mobility rate nacional por dia (soma das multiplicacoes anteriores a dividir pela populacao de Portugal)
mobilidade_nacional <- mobilidade_distritos %>%
group_by(data) %>%
summarise(mobilidade_ponderada = sum(mobilidadexpopulacao) / sum(pop_distritos$populacao))
mobilidade_nacional$data <- as.Date(mobilidade_nacional$data,format = "%d-%m-%Y")
# Grafico da evolucao da taxa de mobilidade nacional
mobilidade_nacional_grafico <- ggplot(mobilidade_nacional, aes(x = data, y = mobilidade_ponderada)) +
geom_point(size = 0.7, aes(text = paste('Data: ', data,
'<br>Taxa de Mobilidade:', mobilidade_ponderada))) +
geom_smooth(se = FALSE, size = 0.7, color = "#64CEAA") +
labs(title = "Evolução da Taxa de Mobilidade (MR) Nacional",
x = "MĂȘs",
y = "MR") +
theme_classic() +
theme(legend.title = element_blank()) +
scale_x_date(breaks = "months", date_labels = "%b") +
geom_line(aes(y = 1, text = ""), size = 0.5, color = "black", linetype = "dotted") +
scale_y_continuous(breaks = seq(0, 1.1, 0.2))
ggplotly(mobilidade_nacional_grafico, tooltip = "text")
De modo a percebermos a evolução da taxa de mobilidade em Portugal, decidimos fazer trĂȘs mapas em trĂȘs situaçÔes epidemiolĂłgicas distintas.
Começåmos por fazer um mapa da mobilidade antes do inĂcio da pandemia em Portugal, tendo para isso escolhido o dia 01-03-2020 por ser a primeira data que temos na nossa base de dados.
# MAPA DA MOBILIDADE POR DISTRITOS
## Mapa do dia 2020-03-01 (antes da pandemia)
### Selecionar todas as linhas do dia 2020-03-01
mobilidade_pre_covid <- as.data.frame(with(mobilidade_pt, mobilidade_pt[(ds=="2020-03-01")]))
### Ordenar os distritos pela mesma ordem do que as do mapa
ordem <- c("Setubal", "Azores", "Madeira", "Aveiro", "Leiria", "Viana do Castelo", "Beja", "Evora", "Faro", "Lisboa", "Portalegre", "Santarem", "Braga", "Braganca", "Castelo Branco", "Coimbra", "Guarda", "Porto", "Viseu", "Vila Real")
mobilidade_pre_covid_ordem <- mobilidade_pre_covid %>%
slice(match(ordem,polygon_name))
### Fazer uma palete de cores com 100 tonalidades e aplica-las ao intervalo entre 0.3 e 1.21 que sao o mĂnimo e o maximo do mobility rate
palete <- colorRampPalette(colors = c("white", "yellow", "pink", "red"), space = "Lab")(100)
pal_mobilidade_covid <- colorNumeric(palete, domain = c(0.3, 1.21))
### Criar legenda para quando se passa o rato por cima
labels_mobilidade_pre_covid <- paste(
"<strong>", mobilidade_pre_covid_ordem[,5],"</strong><br/>",
mobilidade_pre_covid_ordem[,6], " <br/>",
sep="") %>%
lapply(htmltools::HTML)
### Criar o mapa com os valores por distrito
leaflet(mapa_distritos) %>%
addPolygons(stroke = TRUE, smoothFactor = 0.3, fillOpacity = 1, color = "black", weight = 1,
fillColor = ~pal_mobilidade_covid(mobilidade_pre_covid_ordem$all_day_bing_tiles_visited_relative_change),
label = labels_mobilidade_pre_covid,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"), textsize = "13px", direction = "auto")) %>%
addTiles(group = "Normal") %>%
addProviderTiles(providers$CartoDB.Positron, group = "Claro") %>%
addProviderTiles(providers$CartoDB.DarkMatterNoLabels, group = "Escuro") %>%
addLayersControl(
baseGroups = c("Normal", "Claro", "Escuro"),
options = layersControlOptions(collapsed = TRUE)
) %>%
addLegend("bottomleft", pal = pal_mobilidade_covid, values = mobilidade_pre_covid_ordem$all_day_bing_tiles_visited_relative_change,
opacity = 0.5, title = "Taxa de Mobilidade por distrito dia 01-03-2020")
De seguida fizĂ©mos um mapa da taxa de mobilidade para um dia do perĂodo de quarentena em Portugal.
Com a anĂĄlise deste mapa Ă© possĂvel verificar que a taxa de mobilidade diminuiu consideravelmente, apresentando valores entre os 30 e os 42%, o que significa que se mantiveram apenas 30 a 42% dos movimentos realizados em fevereiro (padrĂŁo). A maior diminuição Ă© verificada no distrito de Lisboa, com uma redução de cerca de 70% das suas deslocaçÔes.
## Mapa do dia 2020-04-10 (em quarentena)
### Selecionar todas as linhas do dia 2020-04-10
mobilidade_covid_quarentena <- as.data.frame(with(mobilidade_pt, mobilidade_pt[(ds=="2020-04-10")]))
### Ordenar os distritos pela mesma ordem do que as do mapa
mobilidade_covid_quarentena_ordem <- mobilidade_covid_quarentena %>%
slice(match(ordem,polygon_name))
### Criar legenda para quando se passa o rato por cima
labels_mobilidade_covid_quarentena <- paste(
"<strong>", mobilidade_covid_quarentena_ordem[,5],"</strong><br/>",
mobilidade_covid_quarentena_ordem[,6], " <br/>",
sep="") %>%
lapply(htmltools::HTML)
### Criar o mapa com os valores por distrito
leaflet(mapa_distritos) %>%
addPolygons(stroke = TRUE, smoothFactor = 0.3, fillOpacity = 1, color = "black", weight = 1,
fillColor = ~pal_mobilidade_covid(mobilidade_covid_quarentena_ordem$all_day_bing_tiles_visited_relative_change),
label = labels_mobilidade_covid_quarentena,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"), textsize = "13px", direction = "auto")) %>%
addTiles(group = "Normal") %>%
addProviderTiles(providers$CartoDB.Positron, group = "Claro") %>%
addProviderTiles(providers$CartoDB.DarkMatterNoLabels, group = "Escuro") %>%
addLayersControl(
baseGroups = c("Normal", "Claro", "Escuro"),
options = layersControlOptions(collapsed = TRUE)
) %>%
addLegend("bottomleft", pal = pal_mobilidade_covid, values = mobilidade_covid_quarentena_ordem$all_day_bing_tiles_visited_relative_change,
opacity = 0.5, title = "Taxa de Mobilidade por distrito dia 10-04-2020")
Por fim realizĂĄmos um mapa da taxa de mobilidade no primeiro dia de aulas em Portugal.
Ă possĂvel verificar que a taxa de mobilidade sofreu um aumento em relação ao dia 01-03-2020, data na qual ainda nĂŁo havia casos em Portugal. Isto pode dever-se ao facto do mĂȘs de setembro ter normalmente mais movimentaçÔes do que o mĂȘs de março, independentemente da pandemia. Assim, idealmente dever-se-ia usar como padrĂŁo o mesmo mĂȘs do ano anterior para se perceber se efetivamente a taxa de mobilidade em setembro aumentou.
## Mapa do dia 2020-09-14 (regresso Ă s aulas)
### Selecionar todas as linhas do dia 2020-09-14
mobilidade_covid_aulas <- as.data.frame(with(mobilidade_pt, mobilidade_pt[(ds=="2020-09-14")]))
### Ordenar os distritos pela mesma ordem do que as do mapa
mobilidade_covid_aulas_ordem <- mobilidade_covid_aulas %>%
slice(match(ordem,polygon_name))
### Criar legenda para quando se passa o rato por cima
labels_mobilidade_covid_aulas <- paste(
"<strong>", mobilidade_covid_aulas_ordem[,5],"</strong><br/>",
mobilidade_covid_aulas_ordem[,6], " <br/>",
sep="") %>%
lapply(htmltools::HTML)
### Criar o mapa com os valores por distrito
leaflet(mapa_distritos) %>%
addPolygons(stroke = TRUE, smoothFactor = 0.3, fillOpacity = 1, color = "black", weight = 1,
fillColor = ~pal_mobilidade_covid(mobilidade_covid_aulas_ordem$all_day_bing_tiles_visited_relative_change),
label = labels_mobilidade_covid_aulas,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"), textsize = "13px", direction = "auto")) %>%
addTiles(group = "Normal") %>%
addProviderTiles(providers$CartoDB.Positron, group = "Claro") %>%
addProviderTiles(providers$CartoDB.DarkMatterNoLabels, group = "Escuro") %>%
addLayersControl(
baseGroups = c("Normal", "Claro", "Escuro"),
options = layersControlOptions(collapsed = TRUE)
) %>%
addLegend("bottomleft", pal = pal_mobilidade_covid, values = mobilidade_covid_aulas_ordem$all_day_bing_tiles_visited_relative_change,
opacity = 0.5, title = "Taxa de Mobilidade por distrito dia 14-09-2020")
Com a anĂĄlise deste grĂĄfico vemos que Lisboa Ă© o distrito que, ao longo de todos os meses, tem tido a maior redução da taxa de mobilidade. Durante o perĂodo de quarentena, Beja foi o distrito com menor redução da taxa de mobilidade, mantendo cerca de 70% das suas deslocaçÔes. A partir de maio as movimentaçÔes começaram a subir em todos os distritos, sendo que os que foram consideravelmente superiores ao padrĂŁo foram Vila Real, Viana do Castelo, Faro e Açores. O distrito de Ăvora apresenta um comportamento diferente de todos os outros distritos uma vez que o valor mĂĄximo da taxa de mobilidade nĂŁo ocorreu durante as fĂ©rias de verĂŁo, estando ainda com uma tendĂȘncia crescente.
### Grafico com data no eixo do x, mobility rate no eixo do y e distrito nas cores das linhas
mobilidade_grafico <- ggplot(mobilidade_pt, aes(x = ds, y = all_day_bing_tiles_visited_relative_change, color = polygon_name)) +
geom_point(size = 0.7, aes(text = paste('Distrito:', polygon_name,
'<br>Data: ', ds,
'<br>Taxa de Mobilidade:', all_day_bing_tiles_visited_relative_change))) +
geom_smooth(se = FALSE, size = 0.7) +
labs(title = "Evolução da Taxa de Mobilidade (MR) por Distrito",
x = "MĂȘs",
y = "MR") +
theme_classic() +
theme(legend.title = element_blank()) +
scale_x_date(breaks = "months", date_labels = "%b") +
geom_line(aes(y = 1, text = ""), size = 0.5, color = "black", linetype = "dotted")
ggplotly(mobilidade_grafico, tooltip = "text")
Para perceber se a mobilidade afeta o nĂșmero de novos casos, tivemos de calcular a taxa de crescimento de novos casos. Segundo o The Lancet, a taxa de crescimento de novos casos calcula-se dividindo o logaritmo da mĂ©dia de novos casos dos Ășltimos 3 dias pelo logaritmo da mĂ©dia de novos casos dos Ășltimos 7 dias.
Para alĂ©m de analisarmos a mĂ©dia de novos casos dos Ășltimos 3 dias e a taxa de crescimento de novos casos durante todo o perĂodo da pandemia, iremos apresentar tambĂ©m, separadamente, a anĂĄlise referente a 2 perĂodos distintos. O primeiro Ă© de março a maio, perĂodo no qual ainda nĂŁo eram aplicadas algumas importantes medidas de mitigação, nomeadamente a obrigatoriedade do uso de mĂĄscaras em locais fechados. O segundo perĂodo Ă© de maio Ă atualidade, no qual as medidas de mitigação jĂĄ eram aplicadas mantendo-se semelhantes ao longo de todos os meses.
Com a anĂĄlise do primeiro grĂĄfico observamos que a curva da tendĂȘncia da mĂ©dia dos novos casos dos Ășltimos 3 dias aumentou atĂ© ao mĂȘs de maio, tendo diminuĂdo atĂ© meados de agosto. A partir de setembro a mĂ©dia de novos casos começou novamente a subir tendo ultrapassado os valores do inĂcio da pandemia. Esta curva continua com tendĂȘncia crescente apresentando um declive bastante acentuado.
No segundo grĂĄfico Ă© possĂvel verificar que a taxa de crescimento de novos casos teve o seu valor mĂĄximo no inĂcio da pandemia, diminuindo de seguida atĂ© meados de maio. A partir de setembro a taxa de crescimento de novos casos tem sido superior a 1 o que significa que a taxa de crescimento dos Ășltimos 3 dias foi superior Ă dos Ășltimos 7 dias.
# Para isso, fizemos uma tabela com uma coluna para a data e outra coluna para a divisao. Para a data, começa na linha 7 porque e o primeiro dia em que temos registos dos 7 dias anteriores. Para o numerador tem de se comecar na linha 5 pois o primeiro valor que queremos e para a linha 7 e ele precisa das duas linhas anteriores para fazer a rollmean dos ultimos 3 dias. Para o demoninador nao precisamos de especificar onde queremos que comece porque ele so comeca quando tem 7 registos disponiveis
gr <- as.data.frame(cbind(covid19pt[7:nrow(covid19pt),1], as.data.frame(log(rollmean(covid19pt[5:nrow(covid19pt),12], k=3))
/log(rollmean(covid19pt[,12], k = 7)))))
names(gr) <- c("data", "Growth_Rate")
# Grafico da evolucao da taxa de crescimento de novos casos a nivel nacional
gr_evolucao_grafico <- ggplot(gr, aes(x = data, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Data: ', data,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
ylim(0.7, 1.5) + # ver se isto pode ser mesmo aplicado
labs(title = "Evolução da Taxa de Crescimento de Novos Casos (GR)",
x = "MĂȘs",
y = "GR") +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size=9),
axis.title.y = element_text(size=9)) +
scale_x_date(breaks = "months", date_labels = "%b")
gr_evolucao_grafico_interativo <- ggplotly(gr_evolucao_grafico, tooltip = "text")
# Grafico da evolucao da media de casos dos ultimos 3 dias
rollmean_3_nacional <- as.data.frame(cbind(covid19pt[3:nrow(covid19pt),1], as.data.frame(rollmean(covid19pt[,12], k=3))))
rollmean_3_nacional_grafico <- ggplot(rollmean_3_nacional, aes(x = data, y = confirmados_novos)) +
geom_point(size = 0.7, aes(text = paste('Data: ', data,
'<br>Novos casos (Média):', confirmados_novos))) +
geom_smooth(color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
labs(title = "Evolução dos Novos Casos (MĂ©dia dos Ăltimos 3 dias)",
x = "MĂȘs",
y = "Novos Casos (MĂ©dia dos Ăltimos 3 dias)") +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size=9),
axis.title.y = element_text(size=9)) +
scale_x_date(breaks = "months", date_labels = "%b")
rollmean_3_nacional_grafico_interativo <- ggplotly(rollmean_3_nacional_grafico, tooltip = "text")
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
rollmean_3_nacional_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
gr_evolucao_grafico_interativo
)
))
)
Como expectĂĄvel, no inĂcio da pandemia a taxa de crescimento de novos casos era elevada e foi diminuindo sucessivamente atĂ© valores inferiores a 1, o que significa que a taxa de crescimento de novos casos nos Ășltimos 3 dias foi inferior Ă da Ășltima semana. Esta diminuição pode dever-se ao perĂodo de quarentena.
#### Grafico da evolucao da taxa de crescimento de novos casos a nivel nacional
gr_marco_maio <- gr %>%
filter(data >= "2020-03-03" & data <= "2020-05-11")
gr_marco_maio_evolucao_grafico <- ggplot(gr_marco_maio, aes(x = data, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Data: ', data,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
ylim(0.7, 1.5) +
labs(title = "Evolução da Taxa de Crescimento de Novos Casos (GR)",
x = "MĂȘs",
y = "GR") +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size=9),
axis.title.y = element_text(size=9)) +
scale_x_date(breaks = "months", date_labels = "%b")
gr_marco_maio_evolucao_grafico_interativo <- ggplotly(gr_marco_maio_evolucao_grafico, tooltip = "text")
#### Grafico da evolucao da media de casos dos ultimos 3 dias
rollmean_marco_maio <- rollmean_3_nacional %>%
filter(data >= "2020-03-03" & data <= "2020-05-11")
rollmean_marco_maio_grafico <- ggplot(rollmean_marco_maio, aes(x = data, y = confirmados_novos)) +
geom_point(size = 0.7, aes(text = paste('Data: ', data,
'<br>Novos casos (Média):', confirmados_novos))) +
geom_smooth(color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
labs(title = "Evolução dos Novos Casos (MĂ©dia dos Ăltimos 3 dias)",
x = "MĂȘs",
y = "Novos Casos (MĂ©dia dos Ăltimos 3 dias)") +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size=9),
axis.title.y = element_text(size=9)) +
scale_x_date(breaks = "months", date_labels = "%b")
rollmean_marco_maio_grafico_interativo <- ggplotly(rollmean_marco_maio_grafico, tooltip = "text")
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
rollmean_marco_maio_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
gr_marco_maio_evolucao_grafico_interativo
)
))
)
De maio a setembro a taxa de crescimento de novos casos foi sempre prĂłxima de 1, o que significa que o nĂșmero mĂ©dio de novos casos nos Ășltimos 3 dias foi semelhante Ă mĂ©dia dos Ășltimos 7 dias. A partir de setembro a taxa tem vindo a aumentar para valores acima de 1 o que Ă© concordante com o grĂĄfico Ă esquerda, onde Ă© possĂvel verificar um grande aumento da mĂ©dia de novos casos dos Ășltimos 3 dias.
#### Grafico da evolucao da taxa de crescimento de novos casos a nivel nacional
gr_maio_hoje <- gr %>%
filter(data > "2020-05-11")
gr_maio_hoje_evolucao_grafico <- ggplot(gr_maio_hoje, aes(x = data, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Data: ', data,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
ylim(0.7, 1.5) +
labs(title = "Evolução da Taxa de Crescimento de Novos Casos (GR)",
x = "MĂȘs",
y = "GR") +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size=9),
axis.title.y = element_text(size=9)) +
scale_x_date(breaks = "months", date_labels = "%b")
gr_maio_hoje_evolucao_grafico_interativo <- ggplotly(gr_maio_hoje_evolucao_grafico, tooltip = "text")
#### Grafico da evolucao da media de casos dos ultimos 3 dias
rollmean_maio_hoje<- rollmean_3_nacional %>%
filter(data > "2020-05-11")
rollmean_maio_hoje_grafico <- ggplot(rollmean_maio_hoje, aes(x = data, y = confirmados_novos)) +
geom_point(size = 0.7, aes(text = paste('Data: ', data,
'<br>Novos casos (Média):', confirmados_novos))) +
geom_smooth(color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
labs(title = "Evolução dos Novos Casos (MĂ©dia dos Ăltimos 3 dias)",
x = "MĂȘs",
y = "Novos Casos (MĂ©dia dos Ăltimos 3 dias)") +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size=9),
axis.title.y = element_text(size=9)) +
scale_x_date(breaks = "months", date_labels = "%b")
rollmean_maio_hoje_grafico_interativo <- ggplotly(rollmean_maio_hoje_grafico, tooltip = "text")
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
rollmean_maio_hoje_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
gr_maio_hoje_evolucao_grafico_interativo
)
))
)
A mobilidade nĂŁo tem efeitos imediatos no nĂșmero de novos casos. Assim, temos de perceber quanto tempo demora atĂ© Ă ocorrĂȘncia de uma alteração nesse nĂșmero. Para isso considerĂĄmos que, quando a correlação entre a taxa de mobilidade e a taxa de crescimento de novos casos Ă© mĂĄxima, corresponde ao desfasamento Ăłtimo.
Tendo a taxa de mobilidade nacional e a taxa de crescimento de novos casos a nĂvel nacional, realizĂĄmos um grĂĄfico para cada desfasamento entre 0 e 30 dias, de modo a perceber como Ă© que estas variĂĄveis se relacionam. Pela anĂĄlise dos grĂĄficos Ă© possĂvel verificar que a reta que traça a tendĂȘncia dos pontos tem declive prĂłximo de zero. Isto significa que, apesar do aumento da taxa de mobilidade, a taxa de crescimento de novos casos praticamente nĂŁo se altera.
# Fazer uma tabela com data, growth rate nacional e mobilidade nacional
gr_mr_lag <- left_join(gr, mobilidade_nacional, by = "data")
# Criar variavel com valores do 0 ao 30
lags <- seq(30)
# Atribuir nome a cada futura coluna comecando com mr_ tendo depois o numero respetivo
lag_names <- paste("mr", formatC(lags, width = nchar(max(lags))),
sep = "_")
# Funcao para fazer com que cada coluna seja a coluna anterior descendo uma linha
lag_functions <- setNames(paste("lag(., ", lags, ")"), lag_names)
# Adicionar as colunas anteriores a tabela correlacao
gr_mr_lag <- gr_mr_lag %>%
mutate_at(vars(mobilidade_ponderada), funs_(lag_functions))
# Relacao das variaveis
relacao_grmr <- melt(gr_mr_lag[,-1], id.vars = "Growth_Rate")
levels(relacao_grmr$variable) <- 0:30
ggplot(relacao_grmr, aes(value, Growth_Rate, fill = variable)) +
geom_point() +
facet_wrap(relacao_grmr$variable) +
stat_poly_eq(aes(label = paste(..eq.label..)),
formula = y~x, parse = TRUE, label.y = 0.2) +
geom_smooth(method = "lm", se = FALSE, color = "#64CEAA") +
theme(legend.title = element_blank(),
legend.position = "none",
plot.title = element_text(size = 14),
axis.title.x = element_text(size = 12),
axis.title.y = element_text(size = 12)) +
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa de Mobilidade (MR) para Diferentes Desfasamentos",
x = "MR",
y = "GR")
#### Grafico Marco - Maio
gr_mr_lag_marco_maio <- gr_mr_lag %>%
filter(data >= "2020-03-03" & data <= "2020-05-11")
relacao_marco_maio <- melt(gr_mr_lag_marco_maio[,-1], id.vars = "Growth_Rate")
levels(relacao_marco_maio$variable) <- 0:30
ggplot(relacao_marco_maio, aes(value, Growth_Rate, fill = variable)) +
geom_point() +
facet_wrap(relacao_marco_maio$variable) +
stat_poly_eq(aes(label = paste(..eq.label..)),
formula = y~x, parse = TRUE, label.y = 1) +
geom_smooth(method = "lm", se = FALSE, color = "#64CEAA") +
theme(legend.title = element_blank(),
legend.position = "none",
plot.title = element_text(size = 14),
axis.title.x = element_text(size = 12),
axis.title.y = element_text(size = 12)) +
ylim(0.5, 2) + #alguns valores dos primeiros graficos foram removidos
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa de Mobilidade (MR) entre Março e Maio para Diferentes \nDesfasamentos",
x = "MR",
y = "GR")
#### Grafico Maio - Hoje
gr_mr_lag_maio_hoje <- left_join(gr, mobilidade_nacional, by = "data") %>%
filter(data > "2020-05-11") %>%
mutate_at(vars(mobilidade_ponderada), funs_(lag_functions))
relacao_maio_hoje <- melt(gr_mr_lag_maio_hoje[,-1], id.vars = "Growth_Rate")
levels(relacao_maio_hoje$variable) <- 0:30
ggplot(relacao_maio_hoje, aes(value, Growth_Rate, fill = variable)) +
geom_point() +
facet_wrap(relacao_maio_hoje$variable) +
stat_poly_eq(aes(label = paste(..eq.label..)),
formula = y~x, parse = TRUE, label.y = 0) +
geom_smooth(method = "lm", se = FALSE, color = "#64CEAA") +
theme(legend.title = element_blank(),
legend.position = "none",
plot.title = element_text(size = 14),
axis.title.x = element_text(size = 12),
axis.title.y = element_text(size = 12)) +
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa de Mobilidade (MR) entre Maio e Hoje para Diferentes \nDesfasamentos",
x = "MR",
y = "GR")
Ao realizar a correlação entre as taxa de mobilidade e a taxa de crescimento de novos casos para os diferentes desfasamentos, verificamos que a correlação é måxima quando o desfasamento é de 17 dias. No entanto, esta correlação é de apenas 0.25 o que indica uma fraca correlação entre as duas variåveis.
No grĂĄfico Ă direita Ă© possĂvel ver que, no desfasamento Ăłtimo, com o aumento da taxa de mobilidade, a taxa de crescimento de novos casos nĂŁo apresenta grande aumento. Isto Ă© confirmado pelo declive prĂłximo de zero que a reta de regressĂŁo linear apresenta.
Assim podemos concluir que, para o perĂdo de março Ă atualidade, o aumento da taxa de crescimento de novos casos nĂŁo Ă© explicado pelo aumento da taxa de mobilidade.
# Ver correlacao
correlacao <- gr_mr_lag[-1] %>%
correlate() %>%
focus(Growth_Rate)
correlacao[1] = 0:30
names(correlacao) = c("Lag", "correlacao")
correlacao_grafico <- ggplot(correlacao, aes(x = Lag, y = correlacao)) +
geom_point(aes(text = paste('Lag: ', Lag,
'<br>Correlação: ', correlacao))) +
geom_line() +
geom_rect(xmin= 16, xmax= 18, ymin=-0.09, ymax=0.3, fill="#64CEAA", size=0.1, alpha = 0.4,
aes(fill="Correlação \nsuperior a 0.24")) +
theme(legend.title = element_blank(),
plot.title = element_text(size=8),
legend.text = element_text(size=6),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
labs(title = "Correlação entre Taxa de Mobilidade (MR) e Taxa de Crescimento \nde Novos Casos (GR) em Diferentes Desfasamentos (Lag)",
x = "Lag (dias)",
y = "Correlação entre MR e GR") +
scale_x_continuous(breaks = seq(0, 30, 2))
correlacao_grafico_interativo <- ggplotly(correlacao_grafico, tooltip = "text")
# Ver correlacao para lag 17
grmr_grafico <- ggplot(gr_mr_lag, aes(x = mr_17, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Taxa de Mobilidade: ', mr_17,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(method = "lm", color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
stat_poly_eq(formula = y~x,
aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")),
parse = TRUE) +
theme(plot.title = element_text(size=8),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
ylim(0, 1.5) +
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa \nde Mobilidade (MR) para Lag de 17 dias",
x = "MR",
y = "GR") +
scale_x_continuous(breaks = seq(0, 1, 0.1))
grmr_grafico_interativo <- ggplotly(grmr_grafico, tooltip = "text") %>%
layout(annotations = list(x = 0.7, y = 0.4, text = "y = 0.963 + 0.0473 x", showarrow = FALSE))
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
correlacao_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
grmr_grafico_interativo
)
))
)
De seguida decidimos realizar a correlação entre as taxa de mobilidade e a taxa de crescimento de novos casos para os diferentes desfasamentos, para o perĂodo de março a maio. VerificĂĄmos que a correlação Ă© mĂĄxima quando o desfasamento Ă© de 9 dias, apresentando o valor de cerca de 0.80, indicando uma forte correlação entre as duas variĂĄveis.
No grĂĄfico Ă direita Ă© possĂvel ver que, para o desfasamento Ăłtimo, o aumento da taxa de mobilidade provoca um aumento da taxa de crescimento de novos casos. Por cada aumento de uma unidade da taxa de mobilidade, a taxa de crescimento de novos casos aumenta aproximadamente 0.258 unidades (declive da reta da regressĂŁo linear).
Assim podemos concluir que, para o perĂdo de março a maio, o aumento da taxa de crescimento de novos casos pode ser explicado pelo aumento da taxa de mobilidade. Apesar de se tratar de um perĂodo de quarentena onde a taxa de mobilidade diminuiu consideravelmente em relação ao padrĂŁo, as poucas deslocaçÔes que eram realizadas justificaram o aumento da taxa de crescimento de novos casos pela ausĂȘncia de importantes medidas de mitigação como a obrigatoriedade de uso de mĂĄscaras em locais fechados, a existĂȘncia de desinfetantes para uso da população e a limitação do nĂșmero de pessoas em determinados espaços.
correlacao_marco_maio <- gr_mr_lag_marco_maio[-1] %>%
correlate() %>%
focus(Growth_Rate)
correlacao_marco_maio[1] = 0:30
names(correlacao_marco_maio) = c("Lag", "correlacao")
correlacao_marco_maio_grafico <- ggplot(correlacao_marco_maio, aes(x = Lag, y = correlacao)) +
geom_point(aes(text = paste('Lag: ', Lag,
'<br>Correlação: ', correlacao))) +
geom_line() +
geom_rect(xmin= 9, xmax= 10, ymin=-2, ymax=1, fill="#64CEAA", size=0.1, alpha = 0.4,
aes(text="Correlação \nsuperior a 0.75")) +
theme(legend.title = element_blank(),
plot.title = element_text(size=7.5),
legend.text = element_text(size=6),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
labs(title = "Correlação entre Taxa de Mobilidade (MR) e Taxa de Crescimento \nde Novos Casos (GR) entre Março e Maio em Diferentes Desfasamentos (Lag)",
x = "Lag (dias)",
y = "Correlação entre MR e GR") +
scale_x_continuous(breaks = seq(0, 30, 2))
correlacao_marco_maio_grafico_interativo <- ggplotly(correlacao_marco_maio_grafico, tooltip = "text")
##### Ver relacao para lag 9
grmr_marco_maio_grafico <- ggplot(gr_mr_lag_marco_maio, aes(x = `mr_ 9`, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Taxa de Mobilidade: ', `mr_ 9`,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(method = "lm", color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
stat_poly_eq(formula = y~x,
aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")),
parse = TRUE) +
theme(plot.title = element_text(size= 7.5),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
ylim(0, 1.5) +
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa \nde Mobilidade (MR) entre Março e Maio para Lag de 9 dias",
x = "MR",
y = "GR") +
scale_x_continuous(breaks = seq(0, 1, 0.1))
grmr_marco_maio_grafico_interativo <- ggplotly(grmr_marco_maio_grafico, tooltip = "text") %>%
layout(annotations = list(x = 0.7, y = 0.4, text = "y = 0.866 + 0.258 x", showarrow = FALSE))
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
correlacao_marco_maio_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
grmr_marco_maio_grafico_interativo
)
))
)
Por fim, ao realizar a correlação entre as taxa de mobilidade e a taxa de crescimento de novos casos para os diferentes desfasamentos, para o perĂodo de maio atĂ© Ă atualidade, verificamos que a correlação Ă© mĂĄxima quando o desfasamento Ă© de 26 dias. No entanto, esta correlação Ă© de apenas 0.20 o que indica uma fraca correlação entre as duas variĂĄveis.
No grĂĄfico Ă direita Ă© possĂvel ver que, no desfasamento Ăłtimo, com o aumento da taxa de mobilidade, a taxa de crescimento de novos casos nĂŁo apresenta grande aumento. Isto Ă© confirmado pelo declive prĂłximo de zero que a reta de regressĂŁo linear apresenta.
Assim podemos concluir que, para o perĂdo de maio Ă atualidade, o aumento da taxa de crescimento de novos casos nĂŁo Ă© explicado pelo aumento da taxa de mobilidade. Isto pode ser devido ao facto de, a partir de maio, terem sido implementadas medidas de mitigação mais rigorosas. Por isso, mesmo quando ocorre um aumento da taxa de mobilidade esta nĂŁo se reflete num aumento da taxa de crescimento de novos casos.
correlacao_maio_hoje <- gr_mr_lag_maio_hoje[-1] %>%
correlate() %>%
focus(Growth_Rate)
correlacao_maio_hoje[1] = 0:30
names(correlacao_maio_hoje) = c("Lag", "correlacao")
correlacao_maio_hoje_grafico <- ggplot(correlacao_maio_hoje, aes(x = Lag, y = correlacao)) +
geom_point(aes(text = paste('Lag: ', Lag,
'<br>Correlação: ', correlacao))) +
geom_line() +
geom_rect(xmin= 26, xmax= 27, ymin=-0.09, ymax=1, fill="#64CEAA", size=0.1, alpha = 0.4,
aes(text="Correlação \nsuperior a 0.20")) +
theme(legend.title = element_blank(),
plot.title = element_text(size=8),
legend.text = element_text(size=6),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
labs(title = "Correlação entre Taxa de Mobilidade (MR) e Taxa de Crescimento \nde Novos Casos (GR) de Maio a Hoje em Diferentes Desfasamentos (Lag)",
x = "Lag (dias)",
y = "Correlação entre MR e GR") +
scale_x_continuous(breaks = seq(0, 30, 2))
correlacao_maio_hoje_grafico_interativo <- ggplotly(correlacao_maio_hoje_grafico, tooltip = "text")
##### Ver relacao para lag 26
grmr_maio_hoje_grafico <- ggplot(gr_mr_lag_maio_hoje, aes(x = mr_26, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Taxa de Mobilidade: ', mr_26,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(method = "lm", color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
stat_poly_eq(formula = y~x,
aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")),
parse = TRUE) +
theme(plot.title = element_text(size=8),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
ylim(0.7, 1.3) +
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa \nde Mobilidade (MR) entre Maio e Hoje para Lag de 26 dias",
x = "MR",
y = "GR") +
scale_x_continuous(breaks = seq(0, 1, 0.1))
grmr_maio_hoje_grafico_interativo <- ggplotly(grmr_maio_hoje_grafico, tooltip = "text") %>%
layout(annotations = list(x = 0.85, y = 0.77, text = "y = 0.93 + 0.078 x", showarrow = FALSE))
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
correlacao_maio_hoje_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
grmr_maio_hoje_grafico_interativo
)
))
)
Com esta anĂĄlise podemos concluir que a mobilidade da população influencia o nĂșmero de novos casos apenas quando nĂŁo existem implementadas medidas de mitigação da COVID19. Nestas circunstĂąncias o desfasamento Ăłtimo Ă© de 9 dias, o que significa que o aumento da mobilidade sĂł vai ter repercussĂ”es no aumento do nĂșmero de novos casos passados 9 dias.
Esta conclusĂŁo reforça, assim, a grande importĂąncia destas medidas como a obrigatoriedade do uso de mĂĄscara e a limitação do nĂșmero de pessoas em locais fechados, a lavagem e desinfeção regular das mĂŁos e a recomendação da adoção do distanciamento social.
#### Com gaussian
glm <- as.data.frame(coefficients(glm(Growth_Rate ~ mobilidade_ponderada, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr1 = coefficients(glm(Growth_Rate ~ `mr_ 1`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr2 = coefficients(glm(Growth_Rate ~ `mr_ 2`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr3 = coefficients(glm(Growth_Rate ~ `mr_ 3`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr4 = coefficients(glm(Growth_Rate ~ `mr_ 4`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr5 = coefficients(glm(Growth_Rate ~ `mr_ 5`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr6 = coefficients(glm(Growth_Rate ~ `mr_ 6`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr7 = coefficients(glm(Growth_Rate ~ `mr_ 7`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr8 = coefficients(glm(Growth_Rate ~ `mr_ 8`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr9 = coefficients(glm(Growth_Rate ~ `mr_ 9`, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr10 = coefficients(glm(Growth_Rate ~ mr_10, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr11 = coefficients(glm(Growth_Rate ~ mr_11, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr12 = coefficients(glm(Growth_Rate ~ mr_12, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr13 = coefficients(glm(Growth_Rate ~ mr_13, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr14 = coefficients(glm(Growth_Rate ~ mr_14, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr15 = coefficients(glm(Growth_Rate ~ mr_15, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr16 = coefficients(glm(Growth_Rate ~ mr_16, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr17 = coefficients(glm(Growth_Rate ~ mr_17, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr18 = coefficients(glm(Growth_Rate ~ mr_18, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr19 = coefficients(glm(Growth_Rate ~ mr_19, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr20 = coefficients(glm(Growth_Rate ~ mr_20, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr21 = coefficients(glm(Growth_Rate ~ mr_21, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr22 = coefficients(glm(Growth_Rate ~ mr_22, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr23 = coefficients(glm(Growth_Rate ~ mr_23, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr24 = coefficients(glm(Growth_Rate ~ mr_24, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr25 = coefficients(glm(Growth_Rate ~ mr_25, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr26 = coefficients(glm(Growth_Rate ~ mr_26, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr27 = coefficients(glm(Growth_Rate ~ mr_27, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr28 = coefficients(glm(Growth_Rate ~ mr_28, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr29 = coefficients(glm(Growth_Rate ~ mr_29, family = "gaussian", data = gr_mr_lag))) %>%
mutate(mr30 = coefficients(glm(Growth_Rate ~ mr_30, family = "gaussian", data = gr_mr_lag))) %>%
rbind(0:30)
names(glm)[1] = "mr0"
glm_inv <- as.data.frame(t(glm[c(2, 3),])) %>%
rownames_to_column(var = "mr")
names(glm_inv) = c("mr", "coeficiente", "lag")
lag_grafico <- ggplot(glm_inv, aes(x = lag, y = coeficiente)) +
geom_point() +
geom_line() +
geom_rect(xmin= 9, xmax= 11, ymin=-0.09, ymax=0.15, fill="#64CEAA", size=0.1, alpha = 0.4) +
labs(title = "Correlação entre Mobility Rate e Growth Rate em Diferentes Desfasamentos (lag)",
x = "Lag (dias)",
y = "Correlação entre MR e GR") +
theme(plot.title = element_text(size=9)) +
scale_x_continuous(breaks = seq(0, 30, 2))
lag_grafico_interativo <- ggplotly(lag_grafico)
# Ver relacao para lag 10
grmr_grafico_2 <- ggplot(gr_mr_lag, aes(x = mr_10, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Taxa de Mobilidade: ', mr_10,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(method = "lm", color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
stat_poly_eq(formula = y~x,
aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")),
parse = TRUE) +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
ylim(0, 1.5) +
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa \nde Mobilidade (MR) para Lag de 10 dias",
x = "MR",
y = "GR") +
scale_x_continuous(breaks = seq(0, 1, 0.1))
grmr_grafico_interativo_2 <- ggplotly(grmr_grafico_2, tooltip = "text")
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
lag_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
grmr_grafico_interativo_2
)
))
)
### Calcular a Generalized Linear Regression (glm) entre growth rate nacional e mobility rate nacional para cada lag
#### Com gaussian
glm <- as.data.frame(coefficients(glm(Growth_Rate ~ mobilidade_ponderada, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr1 = coefficients(glm(Growth_Rate ~ `mr_ 1`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr2 = coefficients(glm(Growth_Rate ~ `mr_ 2`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr3 = coefficients(glm(Growth_Rate ~ `mr_ 3`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr4 = coefficients(glm(Growth_Rate ~ `mr_ 4`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr5 = coefficients(glm(Growth_Rate ~ `mr_ 5`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr6 = coefficients(glm(Growth_Rate ~ `mr_ 6`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr7 = coefficients(glm(Growth_Rate ~ `mr_ 7`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr8 = coefficients(glm(Growth_Rate ~ `mr_ 8`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr9 = coefficients(glm(Growth_Rate ~ `mr_ 9`, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr10 = coefficients(glm(Growth_Rate ~ mr_10, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr11 = coefficients(glm(Growth_Rate ~ mr_11, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr12 = coefficients(glm(Growth_Rate ~ mr_12, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr13 = coefficients(glm(Growth_Rate ~ mr_13, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr14 = coefficients(glm(Growth_Rate ~ mr_14, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr15 = coefficients(glm(Growth_Rate ~ mr_15, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr16 = coefficients(glm(Growth_Rate ~ mr_16, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr17 = coefficients(glm(Growth_Rate ~ mr_17, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr18 = coefficients(glm(Growth_Rate ~ mr_18, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr19 = coefficients(glm(Growth_Rate ~ mr_19, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr20 = coefficients(glm(Growth_Rate ~ mr_20, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr21 = coefficients(glm(Growth_Rate ~ mr_21, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr22 = coefficients(glm(Growth_Rate ~ mr_22, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr23 = coefficients(glm(Growth_Rate ~ mr_23, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr24 = coefficients(glm(Growth_Rate ~ mr_24, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr25 = coefficients(glm(Growth_Rate ~ mr_25, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr26 = coefficients(glm(Growth_Rate ~ mr_26, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr27 = coefficients(glm(Growth_Rate ~ mr_27, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr28 = coefficients(glm(Growth_Rate ~ mr_28, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr29 = coefficients(glm(Growth_Rate ~ mr_29, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
mutate(mr30 = coefficients(glm(Growth_Rate ~ mr_30, family = "gaussian", data = gr_mr_lag_marco_maio))) %>%
rbind(0:30)
names(glm)[1] = "mr0"
glm_inv <- as.data.frame(t(glm[c(2, 3),])) %>%
rownames_to_column(var = "mr")
names(glm_inv) = c("mr", "coeficiente", "lag")
lag_grafico <- ggplot(glm_inv, aes(x = lag, y = coeficiente)) +
geom_point() +
geom_line() +
#geom_rect(xmin= 26, xmax= 27, ymin=-0.04, ymax=0.15, fill="coral2", size=0.1, alpha = 0.4,
#aes(text="Correlação \nsuperior a 0.06")) +
labs(title = "Correlação entre Mobility Rate e Growth Rate entre Março e Maio em Diferentes Desfasamentos (lag)",
x = "Lag (dias)",
y = "Correlação entre MR e GR") +
scale_x_continuous(breaks = seq(0, 30, 2))
ggplotly(lag_grafico)
## Calcular a Generalized Linear Regression (glm) entre growth rate nacional e mobility rate nacional para cada lag
#### Com gaussian
glm <- as.data.frame(coefficients(glm(Growth_Rate ~ mobilidade_ponderada, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr1 = coefficients(glm(Growth_Rate ~ `mr_ 1`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr2 = coefficients(glm(Growth_Rate ~ `mr_ 2`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr3 = coefficients(glm(Growth_Rate ~ `mr_ 3`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr4 = coefficients(glm(Growth_Rate ~ `mr_ 4`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr5 = coefficients(glm(Growth_Rate ~ `mr_ 5`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr6 = coefficients(glm(Growth_Rate ~ `mr_ 6`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr7 = coefficients(glm(Growth_Rate ~ `mr_ 7`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr8 = coefficients(glm(Growth_Rate ~ `mr_ 8`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr9 = coefficients(glm(Growth_Rate ~ `mr_ 9`, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr10 = coefficients(glm(Growth_Rate ~ mr_10, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr11 = coefficients(glm(Growth_Rate ~ mr_11, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr12 = coefficients(glm(Growth_Rate ~ mr_12, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr13 = coefficients(glm(Growth_Rate ~ mr_13, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr14 = coefficients(glm(Growth_Rate ~ mr_14, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr15 = coefficients(glm(Growth_Rate ~ mr_15, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr16 = coefficients(glm(Growth_Rate ~ mr_16, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr17 = coefficients(glm(Growth_Rate ~ mr_17, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr18 = coefficients(glm(Growth_Rate ~ mr_18, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr19 = coefficients(glm(Growth_Rate ~ mr_19, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr20 = coefficients(glm(Growth_Rate ~ mr_20, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr21 = coefficients(glm(Growth_Rate ~ mr_21, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr22 = coefficients(glm(Growth_Rate ~ mr_22, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr23 = coefficients(glm(Growth_Rate ~ mr_23, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr24 = coefficients(glm(Growth_Rate ~ mr_24, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr25 = coefficients(glm(Growth_Rate ~ mr_25, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr26 = coefficients(glm(Growth_Rate ~ mr_26, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr27 = coefficients(glm(Growth_Rate ~ mr_27, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr28 = coefficients(glm(Growth_Rate ~ mr_28, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr29 = coefficients(glm(Growth_Rate ~ mr_29, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
mutate(mr30 = coefficients(glm(Growth_Rate ~ mr_30, family = "gaussian", data = gr_mr_lag_maio_hoje))) %>%
rbind(0:30)
names(glm)[1] = "mr0"
glm_inv <- as.data.frame(t(glm[c(2, 3),])) %>%
rownames_to_column(var = "mr")
names(glm_inv) = c("mr", "coeficiente", "lag")
lag_grafico <- ggplot(glm_inv, aes(x = lag, y = coeficiente)) +
geom_point() +
geom_line() +
geom_rect(xmin= 26, xmax= 27, ymin=-0.04, ymax=0.15, fill="#64CEAA", size=0.1, alpha = 0.4,
aes(text="Correlação \nsuperior a 0.06")) +
labs(title = "Correlação entre Mobility Rate e Growth Rate entre Maio e Hoje em Diferentes Desfasamentos (lag)",
x = "Lag (dias)",
y = "Correlação entre MR e GR") +
scale_x_continuous(breaks = seq(0, 30, 2))
lag_grafico_interativo <- ggplotly(lag_grafico)
# Ver relacao para lag 26
grmr_grafico_2 <- ggplot(gr_mr_lag, aes(x = mr_26, y = Growth_Rate)) +
geom_point(size = 0.7, aes(text = paste('Taxa de Mobilidade: ', mr_26,
'<br>Taxa de Crescimento de Novos Casos:', Growth_Rate))) +
geom_smooth(method = "lm", color = "#64CEAA", se = FALSE, formula = y~x, size = 0.7) +
stat_poly_eq(formula = y~x,
aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")),
parse = TRUE) +
theme(plot.title = element_text(size=9),
axis.title.x = element_text(size = 8),
axis.title.y = element_text(size = 8)) +
ylim(0.8, 1.1) +
labs(title = "Relação da Taxa de Crescimento de Novos Casos (GR) com a Taxa \nde Mobilidade (MR) entre Maio e Hoje para Lag de 26 dias",
x = "MR",
y = "GR") +
scale_x_continuous(breaks = seq(0, 1, 0.1))
grmr_grafico_2_interativo <- ggplotly(grmr_grafico_2, tooltip = "text")
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
lag_grafico_interativo
),
tags$div(
style = 'width:50%;display:block;float:left;',
grmr_grafico_2_interativo
)
))
)
RelatĂłrio de Carolina Merca & Raquel Costa
karolmerka@hotmail.com & raqueldelobocosta@gmail.com
Â